home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Hardcore Visual Basic 5.0 (2nd Edition)
/
Hardcore Visual Basic 5.0 - Second Edition (1997)(Microsoft Press).iso
/
Code
/
TFolder.frm
< prev
next >
Wrap
Text File
|
1997-06-14
|
11KB
|
361 lines
VERSION 5.00
Begin VB.Form FShellFolder
Caption = "Test Shell Folders"
ClientHeight = 5400
ClientLeft = 1500
ClientTop = 4110
ClientWidth = 8490
Icon = "TFolder.frx":0000
LinkTopic = "Form1"
ScaleHeight = 5400
ScaleWidth = 8490
Begin VB.ComboBox cboWalk
Height = 315
ItemData = "TFolder.frx":0CFA
Left = 120
List = "TFolder.frx":0D07
Style = 2 'Dropdown List
TabIndex = 12
Top = 2604
Width = 1200
End
Begin VB.CommandButton cmdBrowse
Caption = "... "
BeginProperty Font
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 300
Left = 1992
TabIndex = 11
Top = 3468
Width = 330
End
Begin VB.CommandButton cmdStop
Caption = "Stop!"
Height = 336
Left = 1416
TabIndex = 10
Top = 2616
Width = 960
End
Begin VB.CommandButton cmdWalkDir
Caption = "Walk One Directory"
Height = 372
Left = 120
TabIndex = 9
Top = 1614
Width = 2256
End
Begin VB.CommandButton cmdWalkFolder
Caption = "Walk One Folder"
Height = 372
Left = 120
TabIndex = 8
Top = 1104
Width = 2256
End
Begin VB.CommandButton cmdWalkDirs
Caption = "Walk All Directories"
Height = 372
Left = 120
TabIndex = 7
Top = 594
Width = 2256
End
Begin VB.CheckBox chkPath
Caption = "Use Path"
Height = 240
Left = 120
TabIndex = 6
Top = 3156
Value = 1 'Checked
Width = 1056
End
Begin VB.CommandButton cmdContext
Caption = "Context Menu"
Height = 372
Left = 120
TabIndex = 5
Top = 2124
Width = 2256
End
Begin VB.ListBox lstSpecial
Height = 1035
ItemData = "TFolder.frx":0D2B
Left = 120
List = "TFolder.frx":0D2D
TabIndex = 3
Top = 4056
Width = 2268
End
Begin VB.TextBox txtPath
Height = 312
Left = 120
TabIndex = 2
Top = 3456
Width = 1836
End
Begin VB.TextBox txtOut
Height = 5184
Left = 2460
MultiLine = -1 'True
ScrollBars = 3 'Both
TabIndex = 1
Top = 108
Width = 5904
End
Begin VB.CommandButton cmdWalkFolders
Caption = "Walk All Folders"
Height = 372
Left = 120
TabIndex = 0
Top = 84
Width = 2256
End
Begin VB.Label lbl
Caption = "Special folders:"
Height = 192
Index = 1
Left = 108
TabIndex = 4
Top = 3804
Width = 2268
End
End
Attribute VB_Name = "FShellFolder"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Implements IUseFolder
Implements IUseFile
Private fWalkAll As Long
Private fStop As Long
Private Sub Form_Load()
With lstSpecial
.AddItem "Desktop"
.ItemData(.NewIndex) = &H0
.AddItem "Programs"
.ItemData(.NewIndex) = &H2
.AddItem "Controls"
.ItemData(.NewIndex) = &H3
.AddItem "Printers"
.ItemData(.NewIndex) = &H4
.AddItem "Personal"
.ItemData(.NewIndex) = &H5
.AddItem "Favorites"
.ItemData(.NewIndex) = &H6
.AddItem "Startup"
.ItemData(.NewIndex) = &H7
.AddItem "Recent"
.ItemData(.NewIndex) = &H8
.AddItem "SendTo"
.ItemData(.NewIndex) = &H9
.AddItem "Bitbucket"
.ItemData(.NewIndex) = &HA
.AddItem "StartMenu"
.ItemData(.NewIndex) = &HB
.AddItem "DesktopDirectory"
.ItemData(.NewIndex) = &H10
.AddItem "Drives"
.ItemData(.NewIndex) = &H11
.AddItem "Network"
.ItemData(.NewIndex) = &H12
.AddItem "Nethood"
.ItemData(.NewIndex) = &H13
.AddItem "Fonts"
.ItemData(.NewIndex) = &H14
.AddItem "Templates"
.ItemData(.NewIndex) = &H15
.AddItem "Common StartMenu"
.ItemData(.NewIndex) = &H16
.AddItem "Common Programs"
.ItemData(.NewIndex) = &H17
.AddItem "Common Startup"
.ItemData(.NewIndex) = &H18
.AddItem "Common DestkopDirectory"
.ItemData(.NewIndex) = &H19
.AddItem "AppData"
.ItemData(.NewIndex) = &H1A
.AddItem "Printhood"
.ItemData(.NewIndex) = &H1B
.ListIndex = 0
End With
cboWalk.ListIndex = 2
txtPath = GetTempDir
End Sub
Private Sub Form_Activate()
chkPath_Click
End Sub
Private Sub chkPath_Click()
If chkPath Then
txtPath.Enabled = True
txtPath.SetFocus
lstSpecial.Enabled = False
cmdWalkDirs.Enabled = True
cmdWalkDir.Enabled = True
Else
txtPath.Enabled = False
lstSpecial.Enabled = True
cmdWalkDirs.Enabled = False
cmdWalkDir.Enabled = False
End If
End Sub
Private Sub cmdBrowse_Click()
txtPath = BrowseForFolder(, , , "Starting Folder", CSIDL_DRIVES)
End Sub
Private Sub cmdContext_Click()
If chkPath Then
With txtPath
ContextPopMenu hWnd, .Text, .Left, .Top
End With
Else
With lstSpecial
ContextPopMenu hWnd, .ItemData(.ListIndex), .Left, .Top
End With
End If
End Sub
Private Sub cmdStop_Click()
fStop = True
End Sub
Private Sub cmdWalkDir_Click()
txtOut = "Walk one directory: " & sCrLfCrLf
fStop = False
fWalkAll = False
Dim c As Long
WalkFiles Me, WalkType(cboWalk.ListIndex), txtPath, c
txtOut = txtOut & vbCrLf & "File count: " & c & vbCrLf
txtOut.SelStart = Len(txtOut)
End Sub
Private Sub cmdWalkDirs_Click()
txtOut = "Walk directories recursively: " & sCrLfCrLf
fWalkAll = True
WalkAllFiles Me, WalkType(cboWalk.ListIndex), txtPath
End Sub
Private Sub cmdWalkFolder_Click()
Dim folder As IVBShellFolder
txtOut = "Walk one folder: " & sCrLfCrLf
fWalkAll = False
If chkPath Then
Set folder = FolderFromItem(txtPath)
Else
With lstSpecial
Set folder = FolderFromItem(.ItemData(.ListIndex))
End With
End If
Dim c As Long
WalkFolders folder, Me, c, WalkType(cboWalk.ListIndex)
txtOut = txtOut & vbCrLf & "File count: " & c & vbCrLf
txtOut.SelStart = Len(txtOut)
End Sub
Function WalkType(ByVal i As Integer) As EWalkMode
Select Case i
Case 0
WalkType = ewmFolders
Case 1
WalkType = ewmNonfolders
Case 2
WalkType = ewmBoth
End Select
End Function
Private Sub cmdWalkFolders_Click()
Dim folder As IVBShellFolder
txtOut = "Walk folders recursively: " & sCrLfCrLf
fStop = False
fWalkAll = True
If chkPath Then
Set folder = FolderFromItem(txtPath)
Else
With lstSpecial
Set folder = FolderFromItem(.ItemData(.ListIndex))
End With
End If
WalkAllFolders folder, Me, 0, WalkType(cboWalk.ListIndex)
End Sub
Private Sub Form_MouseUp(Button As Integer, Shift As Integer, _
X As Single, Y As Single)
If Button And 2 Then
With lstSpecial
ContextPopMenu hWnd, .ItemData(.ListIndex), .Left, .Top
End With
End If
End Sub
Private Sub txtPath_GotFocus()
txtPath.SelStart = 0
txtPath.SelLength = 256
End Sub
Private Function IUseFolder_UseFolder(UserData As Variant, _
CurFolder As IVBShellFolder, _
ByVal ItemList As Long) As Boolean
' Turn folder and pidl into CFileInfo
With FileInfoFromFolder(CurFolder, ItemList)
Dim s As String, sSize As String
' Don't show size for directories
If (.Attributes And vbDirectory) = 0 Then
sSize = " : " & Format$(.Length, "#,##0")
End If
' Display different information for single or recursive walk
If fWalkAll Then
s = Space$(UserData * 4) & .DisplayName & " (" & _
.TypeName & ") " & .Modified & sSize & vbCrLf
Else
UserData = UserData + 1
s = .DisplayName & " (" & .TypeName & ") " & _
.Modified & sSize & vbCrLf
End If
txtOut = txtOut & s
txtOut.SelStart = Len(txtOut)
' Let other windows process so we can recognize stop flag
DoEvents
If fStop Then IUseFolder_UseFolder = True
End With
End Function
Private Function IUseFile_UseFile(UserData As Variant, _
FilePath As String, _
FileInfo As CFileInfo) As Boolean
With FileInfo
Dim s As String, sSize As String
If (.Attributes And vbDirectory) = 0 Then
sSize = " : " & Format$(.Length, "#,##0")
End If
If fWalkAll Then
s = Space$((UserData - 1) * 4) & .DisplayName & " (" & _
.TypeName & ") " & .Modified & sSize & vbCrLf
Else
UserData = UserData + 1
s = .DisplayName & " (" & .TypeName & ") " & _
.Modified & sSize & vbCrLf
End If
txtOut = txtOut & s
txtOut.SelStart = Len(txtOut)
DoEvents
If fStop Then IUseFile_UseFile = True
End With
End Function